home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Turing / showtm.icl < prev    next >
Encoding:
Modula Implementation  |  1997-04-25  |  9.8 KB  |  362 lines  |  [TEXT/3PRM]
  1. implementation module showtm
  2.  
  3. import    StdClass
  4. from    deltaIOSystem    import UpdateArea
  5. import    deltaPicture
  6. import    StdInt
  7. from    StdString        import length, %
  8. from    StdChar            import toString
  9. from    StdBool            import &&, otherwise
  10. import    StdArray
  11. import    tm
  12.  
  13. StatePos    :== (10,17)
  14. ErrorPos    :== (10,17)
  15. NamePos        :== (130,17)
  16. TapeY        :== 40
  17. Room        :== 14
  18. Offset        :== 10
  19. TransY        :== 40
  20. MaxX        :== 29900
  21.  
  22. /*    Draw a Turing machine: tape, transitions, name and state.
  23. */
  24.  
  25. ShowTape :: !Tape !Picture -> Picture
  26. ShowTape {content,head} pic
  27. #    pic    = EraseRectangle    ((0,0),(MaxX,100))                pic
  28.     pic    = ShowCont            0 (size content) Offset content    pic
  29.     pic    = DrawTapeFrame                                        pic
  30.     pic    = DrawHeadRect        (HeadPos head) RedColour        pic
  31. =    pic
  32. where
  33.     ShowCont :: !Int !Int Int !String !Picture -> Picture
  34.     ShowCont i l x s pic
  35.     |    i==l        = pic
  36.     #    pic            = MovePenTo     (x,TapeY)                pic
  37.         pic            = DrawString (toString (s.[i]))        pic
  38.         pic            = ShowCont     (i+1) l (x+Room) s        pic
  39.     |    otherwise    = pic
  40.     
  41.     DrawTapeFrame :: !Picture -> Picture
  42.     DrawTapeFrame pic
  43.     #    pic    = MovePenTo (x,   y2)        pic
  44.         pic    = LinePenTo (MaxX,y2)        pic
  45.         pic    = MovePenTo (x,   y1)        pic
  46.         pic    = LinePenTo (MaxX,y1)        pic
  47.         pic    = DrawCellBorders x y1 y2    pic
  48.     =    pic
  49.     where
  50.         x    = Offset-4
  51.         y1    = TapeY -13
  52.         y2    = TapeY +5
  53.         
  54.         DrawCellBorders :: !Int Int Int !Picture -> Picture
  55.         DrawCellBorders x y1 y2 pic
  56.         |    x>MaxX        = pic
  57.         #    pic            = MovePenTo            (x,y2)            pic
  58.             pic            = LinePenTo            (x,y1)            pic
  59.             pic            = DrawCellBorders    (x+Room) y1 y2    pic
  60.         |    otherwise    = pic
  61.  
  62. ShowTransitions :: ![Transition] !String !Picture -> Picture
  63. ShowTransitions trs state pic
  64. #    pic    = EraseRectangle    ((0,0),(MaxX,300))    pic
  65.     pic    = ShowState            state                pic
  66.     pic    = ShowTransFrame                        pic
  67.     pic    = DrawTransitions    0 trs                pic
  68. =    pic
  69. where
  70.     ShowState :: !String !Picture -> Picture
  71.     ShowState state pic
  72.     #    pic        = DrawRectangle    ((x-4,y-11),(x+101,y+4))    pic
  73.         pic        = MovePenTo        StatePos                    pic
  74.         pic        = DrawString    "State:"                    pic
  75.         pic        = ShowNextState    state                        pic
  76.     =    pic
  77.     where
  78.         (x,y)    = StatePos
  79.     
  80.     ShowTransFrame :: !Picture -> Picture
  81.     ShowTransFrame pic
  82.     #    pic        = DrawRectangle ((Offset-4,y1),(limit,y2+1)) pic
  83.         pic        = ShowTransBorders (Offset+135) limit y1 y2 pic
  84.     =    pic
  85.     where
  86.         limit    = MaxX-80
  87.         y1        = TransY-14
  88.         y2        = TransY+201
  89.         
  90.         ShowTransBorders :: !Int !Int Int Int !Picture -> Picture
  91.         ShowTransBorders x limit y1 y2 pic
  92.         |    x>=limit    = pic
  93.         #    pic            = MovePenTo (x,y2) pic
  94.             pic            = LinePenTo (x,y1) pic
  95.         |    otherwise    = ShowTransBorders (x+140) limit y1 y2 pic
  96.     
  97.     DrawTransitions :: !Int ![Transition] !Picture -> Picture
  98.     DrawTransitions n [transition:transitions] pic
  99.     #    pic    = DrawTrans n transition pic
  100.         pic    = DrawTransitions (n+1) transitions pic
  101.     =    pic
  102.     DrawTransitions _ _ pic
  103.     =    pic
  104.  
  105. ShowTransition :: !Int !Int !Picture -> Picture
  106. ShowTransition old new pic
  107. #    pic    = DrawTransRect old WhiteColour pic
  108.     pic    = DrawTransRect new RedColour pic
  109. =    pic
  110. where
  111.     DrawTransRect :: !Int !Colour !Picture -> Picture
  112.     DrawTransRect nr color pic
  113.     #    pic        = SetPenColour    color                        pic
  114.         pic        = DrawRectangle    ((x-1,y-11),(x+133,y+4))    pic
  115.         pic        = SetPenColour    BlackColour                    pic
  116.     =    pic
  117.     where
  118.         (x,y)    = TransPos nr
  119.  
  120. DrawTrans :: !Int !Transition !Picture -> Picture
  121. DrawTrans n {start,sigma,end,move} pic
  122. #    pic        = MovePenTo (x+5,y) pic
  123.     pic        = DrawString (start+++","+++toString sigma+++" -> "+++end+++","+++toString move) pic
  124. =    pic
  125. where
  126.     (x,y)    = TransPos n
  127.  
  128. ShowTapePart :: !Tape !Int !Int !Picture -> Picture
  129. ShowTapePart {content,head} start end pic
  130. #    pic    = MovePenTo        (x,   y2)                                            pic
  131.     pic    = LinePenTo        (MaxX,y2)                                            pic
  132.     pic    = MovePenTo        (x,   y1)                                            pic
  133.     pic    = LinePenTo        (MaxX,y1)                                            pic
  134.     pic    = ShowContPart    0 (size content) Offset content (start-30) (end+30)    pic
  135.     pic    = DrawHeadRect    (HeadPos head) RedColour                            pic
  136. =    pic
  137. where
  138.     x    = Offset-4
  139.     y1    = TapeY -13
  140.     y2    = TapeY +5
  141.     
  142.     ShowContPart :: Int Int !Int String Int !Int !Picture -> Picture
  143.     ShowContPart i l x s f t pic
  144.     |    x>t            = pic
  145.     |    x<f            = ShowContPart    (i+1) l (x+Room) s f t    pic
  146.     #    pic            = MovePenTo        (x-4,TapeY+5)            pic
  147.         pic            = LinePenTo        (x-4,TapeY-13)            pic
  148.     |    i>=l        = ShowContPart    (i+1) l (x+Room) s f t    pic
  149.     #    pic            = MovePenTo        (x,TapeY)                pic
  150.         pic            = DrawString    (toString (s.[i]))        pic
  151.     |    otherwise    = ShowContPart    (i+1) l (x+Room) s f t    pic
  152.  
  153.  
  154. /*    Make a step of the T.M. (transition) visible on the screen.
  155. */
  156.            
  157. ShowNewTape :: !Comm !Int !Picture -> Picture
  158. ShowNewTape com pos pic
  159.     = ShowComm com (HeadPos pos) pic
  160. where
  161.     ShowComm :: !Comm !Int !Picture -> Picture
  162.     ShowComm Erase pos pic
  163.     #    pic        = EraseCell        pos pic
  164.         pic        = MoveToHeadPos    pos    pic
  165.         pic        = DrawString "#"    pic
  166.     =    pic
  167.     ShowComm None pos pic
  168.     =    pic
  169.     ShowComm (Write c) pos pic
  170.     #    pic        = EraseCell                pos    pic
  171.         pic        = MoveToHeadPos            pos    pic
  172.         pic        = DrawString (toString c)    pic
  173.     =    pic
  174.     ShowComm MoveR1 pos pic
  175.     #    pic        = MovePenTo        (newpos+2,TapeY)    pic
  176.         pic        = DrawString    "#"                    pic
  177.         pic        = DrawHeadRect    pos    WhiteColour    pic
  178.         pic        = DrawHeadRect    newpos RedColour    pic
  179.     =    pic
  180.     where
  181.         newpos    = pos+Room
  182.     ShowComm MoveR pos pic
  183.     #    pic        = DrawHeadRect pos WhiteColour pic
  184.         pic        = DrawHeadRect newpos RedColour pic
  185.     =    pic
  186.     where
  187.         newpos    = pos+Room
  188.     ShowComm MoveL pos pic
  189.     #    pic        = DrawHeadRect pos WhiteColour pic
  190.         pic        = DrawHeadRect newpos RedColour pic
  191.     =    pic
  192.     where
  193.         newpos    = pos-Room
  194.     ShowComm Halt pos pic
  195.     =    pic
  196.     ShowComm ErrorL pos pic
  197.     =    DrawError "Error: Head went over left edge." pic
  198.     ShowComm ErrorT pos pic
  199.     =    DrawError "Error: No Transition applicable." pic
  200.     ShowComm x pos pic
  201.     =    DrawError "Fatal Error: Unknown Command." pic
  202.  
  203. ShowNextState :: !String !Picture -> Picture
  204. ShowNextState state pic
  205. #    pic             = SetPenColour          RedColour                        pic
  206.     (width, pic) = PictureStringWidth "State: "                     pic
  207.     pic             = EraseRectangle     ((x+width,y-10),(x+100,y+3))    pic
  208.     pic             = MovePenTo          (x+width+1,y)                    pic
  209.     pic             = DrawString          state                            pic
  210.     pic             = SetPenColour          BlackColour                   pic
  211. =    pic
  212. where
  213.     (x,y)    = StatePos
  214.  
  215. DrawHeadRect :: !Int !Colour !Picture -> Picture
  216. DrawHeadRect pos color pic
  217. #    pic        = SetPenColour    color                                pic
  218.     pic        = DrawRectangle    ((pos,TapeY-11),(pos+11,TapeY+4))    pic
  219.     pic        = SetPenColour    BlackColour                            pic
  220. =    pic
  221.  
  222. HeadPos :: !Int -> Int
  223. HeadPos pos = Offset+Room*pos-2
  224.  
  225. TransPos :: !Int -> (!Int,!Int)
  226. TransPos nr = (Offset+140*(nr/14),TransY+15*(nr mod 14))
  227.  
  228. MoveToHeadPos :: !Int !Picture -> Picture
  229. MoveToHeadPos pos pic = MovePenTo (pos+2,TapeY) pic
  230.  
  231. EraseCell :: !Int !Picture -> Picture
  232. EraseCell x pic = EraseRectangle ((x+1,TapeY-10),(x+10,TapeY+3)) pic
  233.  
  234. DrawError :: !String !Picture -> Picture
  235. DrawError mes pic
  236. #    (width,pic)    = PictureStringWidth mes pic
  237.     pic            = DrawRectangle    ((x-5,y-11),(x+width+5,y+4))    pic
  238.     pic            = SetPenColour    RedColour                        pic
  239.     pic            = MovePenTo        (x,y)                            pic
  240.     pic            = SetPenColour    BlackColour                        pic
  241.     pic            = DrawString    mes                                pic
  242. =    pic
  243. where
  244.     (x,y)        = ErrorPos
  245.  
  246. EraseError :: !Picture -> Picture
  247. EraseError pic
  248. =    EraseRectangle ((ex-5,ey-11),(ex+299,ey+4)) pic
  249. where
  250.     (ex,ey)    = ErrorPos
  251.  
  252.  
  253. /*    For the dialogs:
  254. */
  255.  
  256. FourCharString :: !String -> String
  257. FourCharString str
  258. |    size str>4    = str%(0,3)
  259. |    otherwise    = str
  260.  
  261. FirstChar :: !String -> Char
  262. FirstChar str
  263. |    size str==0    = '#'
  264. |    otherwise    = str.[0]
  265.  
  266.  
  267. /*    ClickedIn... determines where the mouse clicked: on a tape cell,
  268.     on a transition, on the state or on the name.
  269. */
  270.  
  271. ClickedInWindow :: !Point -> (!Int,!Bool,!Bool)
  272. ClickedInWindow (x,y)
  273. |    trans            = (trnr,True,False)
  274. |    state            = (0, False, True )
  275. |    otherwise        = (0, False, False)
  276. where
  277.     trans            = InRectangle (x,y) ((Offset,  TransY-13),(MaxX,     TransY+201))
  278.     state            = InRectangle (x,y) ((statex-3,statey-10),(statex+79,statey+3  ))
  279.     trnr            = (x-Offset)/120 * 14 + (y-(TransY-10))/15
  280.     (statex,statey)    = StatePos
  281.  
  282. ClickedInTapeWd :: !Point -> (!Int,!Bool)
  283. ClickedInTapeWd (x,y)
  284. |    tape            = (tpos,True)
  285. |    otherwise        = (0,False)
  286. where
  287.     tape            = InRectangle (x,y) ((Offset,TapeY-11),(MaxX,TapeY+4))
  288.     tpos            = (x-Offset+3)/Room
  289.  
  290. InRectangle :: !Point !Rectangle -> Bool
  291. InRectangle (x,y) ((lx,ly),(ux,uy)) = x>=lx && x<ux && y>ly && y<uy
  292.  
  293.  
  294. /*    Functions to show a change of the T.M. when the T.M. is edited.
  295. */
  296.  
  297. HiliteTransition :: !Int !Transition !Picture -> Picture
  298. HiliteTransition tnr transition pic
  299. #    pic        = SetPenColour    YellowColour            pic
  300.     pic        = FillRectangle    ((x,y-9),(x+131,y+2))    pic
  301.     pic        = SetPenColour    BlackColour                pic
  302.     pic        = DrawTrans        tnr transition            pic
  303. =    pic
  304. where
  305.     (x,y)    = TransPos tnr
  306.            
  307. HiliteState :: !String !Picture -> Picture
  308. HiliteState state pic
  309. #    pic        = SetPenColour    YellowColour            pic
  310.     pic        = FillRectangle    ((x+39,y-9),(x+78,y+2))    pic
  311.     pic        = MovePenTo        (x+40,y)                pic
  312.     pic        = DrawString    state                    pic
  313.     pic        = SetPenColour    BlackColour                pic
  314. =    pic
  315. where
  316.     (x,y)    = StatePos
  317.  
  318. HiliteCell :: !Int !Char !Picture -> Picture
  319. HiliteCell pos cell pic
  320. #    pic    = EraseError                                    pic
  321.     pic    = SetPenColour    YellowColour                    pic
  322.     pic    = FillRectangle    ((x+1,TapeY-10),(x+10,TapeY+3))    pic
  323.     pic    = SetPenColour    BlackColour                        pic
  324.     pic    = MovePenTo        (x+2,TapeY)                        pic
  325.     pic    = DrawString    (toString cell)                    pic
  326. =    pic
  327. where
  328.     x    = HeadPos pos
  329.  
  330. ShowTrans :: !Int !Transition !Picture -> Picture
  331. ShowTrans tnr transition pic
  332. #    pic    = EraseTrans tnr pic
  333.     pic    = DrawTrans  tnr transition pic
  334. =    pic
  335.  
  336. EraseTrans :: !Int !Picture -> Picture
  337. EraseTrans tnr pic
  338. =    EraseRectangle ((x,y-9),(x+131,y+2)) pic
  339. where
  340.     (x,y)    = TransPos tnr
  341.  
  342. DrawTapeCell :: !Int !Char !Picture -> Picture
  343. DrawTapeCell pos cell pic
  344. #    pic    = EraseCell        x                pic
  345.     pic    = MovePenTo        (x+2,TapeY)        pic
  346.     pic    = DrawString    (toString cell)    pic
  347. =    pic
  348. where
  349.     x    = HeadPos pos
  350.  
  351. ShowHeadMove :: !Tape Int Int Int !Picture -> Picture
  352. ShowHeadMove tape=:{head} end left right pic
  353. #    pic = ShowTapePart tape left right                pic
  354.     pic    = DrawHeadRect (HeadPos head)    WhiteColour    pic
  355.     pic    = DrawHeadRect (HeadPos end)    RedColour    pic
  356. =    pic
  357.  
  358. //    Set the font of the Turing machine windows.
  359.  
  360. SetTuringFont :: !Picture -> Picture
  361. SetTuringFont pic = SetFontSize 10 (SetFontName "Courier" pic)
  362.